Visual Basic Toolbox/Visual Basic Toolbox (P.I.E.)(1996).ISO/arrays/vbstrapi/strdllap.frm

Visual Basic Form | 1995-06-24 | 18.8 KB | 511 lines

VERSION 2.00
Begin Form StrDLLApp
   BackColor       =   &H00C0C0C0&
   Caption         =   "VBstrAPI.DLL Demonstrator"
   ClientHeight    =   5985
   ClientLeft      =   45
   ClientTop       =   1410
   ClientWidth     =   8070
   Height          =   6390
   Icon            =   STRDLLAP.FRX:0000
   Left            =   -15
   LinkTopic       =   "Form1"
   ScaleHeight     =   5985
   ScaleWidth      =   8070
   Top             =   1065
   Width           =   8190
   Begin ListBox List
      BackColor       =   &H00808000&
      FontBold        =   0   'False
      FontItalic      =   0   'False
      FontName        =   "Fixedsys"
      FontSize        =   9
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      Height          =   1605
      Left            =   5520
      TabIndex        =   8
      Tag             =   "OL"
      Top             =   270
      Width           =   2475
   End
   Begin TextBox Monitor
      BackColor       =   &H00C0C0C0&
      FontBold        =   0   'False
      FontItalic      =   0   'False
      FontName        =   "Fixedsys"
      FontSize        =   9
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      Height          =   675
      Left            =   150
      MousePointer    =   1  'Arrow
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   1
      Tag             =   "OL"
      Top             =   1980
      Width           =   5265
   End
   Begin PictureBox ToolBar
      BackColor       =   &H00808000&
      Height          =   1875
      Left            =   0
      ScaleHeight     =   1845
      ScaleWidth      =   5400
      TabIndex        =   0
      Tag             =   "OL"
      Top             =   0
      Width           =   5430
      Begin PictureBox Picture1
         AutoSize        =   -1  'True
         BorderStyle     =   0  'None
         Height          =   1800
         Left            =   2970
         Picture         =   STRDLLAP.FRX:0302
         ScaleHeight     =   1800
         ScaleWidth      =   2400
         TabIndex        =   7
         Top             =   30
         Width           =   2400
      End
      Begin SSCommand biQuit
         Caption         =   "&Exit"
         Font3D          =   1  'Raised w/light shading
         ForeColor       =   &H00000000&
         Height          =   1800
         Left            =   2250
         Picture         =   STRDLLAP.FRX:28FC
         RoundedCorners  =   0   'False
         TabIndex        =   6
         Top             =   30
         Width           =   705
      End
      Begin SSCommand biArray
         Caption         =   "&ArrayStr"
         Font3D          =   1  'Raised w/light shading
         Height          =   900
         Left            =   1140
         Picture         =   STRDLLAP.FRX:2B66
         RoundedCorners  =   0   'False
         TabIndex        =   5
         Top             =   930
         Width           =   1095
      End
      Begin SSCommand biCat
         Caption         =   "&CatStr"
         Font3D          =   1  'Raised w/light shading
         Height          =   900
         Left            =   30
         Picture         =   STRDLLAP.FRX:2E68
         RoundedCorners  =   0   'False
         TabIndex        =   4
         Top             =   930
         Width           =   1095
      End
      Begin SSCommand biCopy
         Caption         =   "C&opyFile"
         Font3D          =   1  'Raised w/light shading
         Height          =   885
         Left            =   1140
         Picture         =   STRDLLAP.FRX:316A
         RoundedCorners  =   0   'False
         TabIndex        =   3
         Top             =   30
         Width           =   1095
      End
      Begin SSCommand biFind
         Caption         =   "&FindString"
         Font3D          =   1  'Raised w/light shading
         Height          =   885
         Left            =   30
         Picture         =   STRDLLAP.FRX:346C
         RoundedCorners  =   0   'False
         TabIndex        =   2
         Tag             =   "OL"
         Top             =   30
         Width           =   1095
      End
   End
   Begin Label Label1
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      BackStyle       =   0  'Transparent
      Caption         =   "ArrayStr Demonstration List Box"
      ForeColor       =   &H00800000&
      Height          =   195
      Left            =   5520
      TabIndex        =   9
      Top             =   30
      Width           =   2700
   End
Option Explicit
Sub ArrayExample ()
' Demonstration example of ArrayStr usage
 Dim SHandle As Integer ' ArrayStr object handle
 Dim ii      As Long    ' iterator
 Dim rc      As Long    ' return code
    ' create the sample array string
    SHandle = CreateNewStringArray(1, 1024)
    '
    ' If successful, then away we go
    '
    If SHandle > -1 Then

        '
        '  We'll start by filling the ArrayStr in Serial Mode
        '
        For ii = 0 To 9
            ' put the string NEXT in the list
            rc = PutArrayNext(SHandle, " Originally at line " & ii + 1)
            If rc < 0 Then

                MsgBox "ArrayStr Overflow! Unable to continue.", 48, "PutArrayNext Error"
                DestroyStringArray SHandle

                Exit Sub

            End If
        Next
        ' now insert a string at index #3
        rc = InsertArrayStr(SHandle, 3, "!! Inserted at line 4")

        ' now delete the last string
        rc = DeleteArrayStr(SHandle, 9)
        ' replace the entry #7 with a message using Random Access
        rc = PutArrayStr(SHandle, 7, "!! Changed line 8 with PutArrayStr")
        ' place a note in the last entry that it was deleted
        rc = PutArrayStr(SHandle, 9, "!! Entry deleted by DeleteArrayStr")
        ' reset the current line pointer to the first entry
        ArrayStrSetCLP SHandle, 0
        ' using Serial Mode, fill the demonstration list box
        List.Visible = False
        For ii = 1 To 10
            List.AddItem Format$(ii, "00") & GetArrayNext(SHandle)
        Next
        List.Visible = True
        'rc = ArrayStrResize(SHandle, 20)
        'MsgBox "(" & rc & ") " & GetArrayStr(SHandle, 1) & " [" & ArrayStrElements(SHandle) & "]"
        ' ALWAYS REMEMBER TO DESTROY THE ARRAYSTR WHEN FINISHED
        DestroyStringArray SHandle
    Else
        MsgBox "Not enough memory to create the ArrayStr Object!", 48, "ArrayStr Create Error"
    End If
End Sub
Sub biArray_Click ()
Dim CHandle As Integer
Dim rc As Integer
    ' This call is used to display the demonstration
    ' code for the program.  Please don't look behind
    ' that curtain. (The Wizard of OZ)
    LocateCode "Sub Array" & "Example", "End Sub" & Chr$(13)
    ArrayExample
    CHandle = CreateNewCatString(4096)
    rc = CatStrAddLine(CHandle, "Examine the Code in the Code Window below.")
    rc = CatStrAddLine(CHandle, "")
    rc = CatStrAddLine(CHandle, "Then examine the contents of the ListBox.")
    rc = CatStrAddLine(CHandle, "")
    rc = CatStrAddLine(CHandle, "The ListBox demonstrates the result of the example code.")
    HintMsg CHandle, "ArrayStr Example Code"
    DestroyCatString CHandle
End Sub
Sub biCat_Click ()
 Dim rc      As Integer
 Dim CHandle As Integer
    ' This call is used to display the demonstration
    ' code for the program.  Please don't look behind
    ' that curtain. (The Wizard of OZ)
    On Error Resume Next
    List.Clear
    Kill "CatStr.Txt"
    CHandle = CreateNewCatString(4096)
    Monitor = ""
    LocateCode "Sub Cat" & "Example", "End Sub" & Chr$(13)
    rc = CatStrAddLine(CHandle, "What follows is a demonstration of CatStr vs VB String concatenation times for a 32k string. Only 32k strings are demonstrated because VB can not handle larger strings.")
    rc = CatStrAddLine(CHandle, "")
    rc = CatStrAddLine(CHandle, "When the demonstration is complete, take a look at the code below to see how it works.")
    HintMsg CHandle, "CatStr Example Code"
    DoEvents
    CatExample
    DestroyCatString CHandle
End Sub
' Note: The use of CatStrAddLine in this sub is purely
'       for demonstration purposes.
Sub biCopy_Click ()
Dim CHandle As Integer
Dim rc As Integer
    CopyExample
    CHandle = CreateNewCatString(4096)
    rc = CatStrAddLine(CHandle, "Examine the Code in the Code Window below.")
    rc = CatStrAddLine(CHandle, "")
    rc = CatStrAddLine(CHandle, "The Code in the Code Window demonstrates how to use the CopyFile function.")
    rc = CatStrAddLine(CHandle, "")
    rc = CatStrAddLine(CHandle, "The new file is located in the same directory.")
    HintMsg CHandle, "CopyFile Example Code"
    DestroyCatString CHandle
    ' This call is used to display the demonstration
    ' code for the program.  Please don't look behind
    ' that curtain. (The Wizard of OZ)
    LocateCode "Sub Copy" & "Example", "End Sub" & Chr$(13)
End Sub
' Example use of the FindString() and CatStr Objects
Sub biFind_Click ()
Dim CHandle As Integer
Dim rc As Integer
    CHandle = CreateNewCatString(4096)
    rc = CatStrAddLine(CHandle, "You are about to see a demonstration of how FindString performs against InStr.  FindString works best with large strings and medium size targets (more than 3 characters).")
    rc = CatStrAddLine(CHandle, "")
    rc = CatStrAddLine(CHandle, "After the dialog boxes have shown you how it performs, check out the code in the code window.")
    HintMsg CHandle, "FindString vs InStr Example Code"
    DoEvents
    DestroyCatString CHandle
    ' This call is used to display the demonstration
    ' code for the program.  Please don't look behind
    ' that curtain. (The Wizard of OZ)
    FindExample
    LocateCode "Sub Find" & "Example", "End Sub" & Chr$(13)
End Sub
Sub biQuit_Click ()
    Unload Me
End Sub
' Demonstration of how CatStr out performs VB Strings
' in concatenation speed.
Sub CatExample ()
 Dim CHandle As Integer ' CatStr Object Handle
 Dim rc      As Integer ' return code
 Dim Temp    As String  ' temp string variable for save
 Dim t                  ' timer accumulator
 Dim VBTime
    On Error Resume Next
    ' create the maximum CatStr Object
    CHandle = CreateNewCatString(32768)
    ' Fail if not enough memory
    If CHandle < 0 Then
        MsgBox "Unable to allocate 32k for CatStr!", 48, "CatStr Create Error"
        Exit Sub

    End If
    ' Use 'On Error Goto' to trap when string is full
    '
    ' NOTE: This is the fastest way to do this and simulates
    '       CatStr objects more fairly than determining the
    '       length of the string with Len().
' ****************** Visual Basic String Test ************************
    On Error GoTo VBStrFull
    Temp$ = ""
    Screen.MousePointer = 11
    t = Timer
    While True
        Temp$ = Temp$ & "This is a sample line of text."
    Wend
VBStrFull:
    t = Timer - t
    Screen.MousePointer = 0
    On Error Resume Next
    VBTime = t
    MsgBox "Concatenating a " & Len(Temp$) & " character Visual Basic String took " & Format$(t, "Standard") & " seconds."
' ******************** CatStr String Test ****************************
    rc = 0
    Screen.MousePointer = 11
    t = Timer
    While rc = 0
        rc = CatStrAddLine(CHandle, "This is a sample line of text.")
    Wend
    t = Timer - t
    Screen.MousePointer = 0
    MsgBox "Concatenating a " & CatStrLength(CHandle) & " character CatStr took " & Format$(t, "Standard") & " seconds."
' ************************* Results **********************************
    If t < VBTime Then
        MsgBox "CatStr was " & Format$(VBTime / t, "Standard") & " times faster that VB!"
    Else

        MsgBox "VB was " & Format$(t / VBTime, "Standard") & " times faster that CatStr!"
    End If
    ' ALWAYS REMEMBER TO DESTROY THE OBJECT WHEN FINISHED!
    DestroyCatString CHandle
End Sub
Sub CenterForm (TheForm As Form, OffsetLeft As Integer, OffsetTop As Integer)
Dim FLeft As Integer
Dim FTop As Integer
    If TheForm.WindowState <> 0 Then Exit Sub
    FLeft = ((Screen.Width - TheForm.Width) \ 2) + OffsetLeft
    FTop = (((Screen.Height - TheForm.Height) \ 2) + OffsetTop) * .85
    If TheForm.Left = FLeft And TheForm.Top = FTop Then Exit Sub
    TheForm.Move FLeft, FTop
End Sub
Sub CopyExample ()
Dim rc As Integer
    rc = CopyFile("STRDLLAP.FRM", "COPYFILE.TXT")
    If rc < 0 Then MsgBox "CopyFile Function failed!", 48, "CopyFile Error #" & rc
End Sub
Sub FindExample ()
'  Sample of FindString usage
'  Many thanks to Jim Moran at Honeywell for the challenge of
'  this example!
'  Don't forget to check out CatStrFind() in the help file!
 Dim SrcString    As String
 Dim TargetString As String
 Dim locn         As Long
 Dim InStrTime
 Dim FindStringTime
 Dim ii           As Integer
    SrcString = String$(32000, "A") + "BBB"
    TargetString = "AAAAAAAAAAAABBB"
    ' first show how InStr performs
    Screen.MousePointer = 11
    InStrTime = Timer
    For ii = 1 To 10
        locn = InStr(1, SrcString, TargetString)
    Next
    InStrTime = Timer - InStrTime
    Screen.MousePointer = 0
    MsgBox "(Found At " & locn & ") InStr took " & Format$(InStrTime / 10, "###.###0") & " seconds."
    ' now show how FindString performs
    Screen.MousePointer = 11
    FindStringTime = Timer
    For ii = 1 To 10
        locn = FindString(1, SrcString, TargetString)
    Next
    FindStringTime = Timer - FindStringTime
    Screen.MousePointer = 0
    MsgBox "(Found At " & locn & ") FindString took " & Format$(FindStringTime / 10, "###.###0") & " seconds."
    If FindStringTime < InStrTime Then
        MsgBox "FindString was " & Format$(InStrTime / FindStringTime, "###.###0") & " times faster."
    Else

        MsgBox "InStr was " & Format$(FindStringTime / InStrTime, "###.###0") & " times faster."
    End If
End Sub
Sub Form_Load ()
    On Error Resume Next
    CenterForm Me, 0, 0
    ChDir App.Path
    Me.Top = Screen.Height * .05
    Me.Height = Screen.Height * .9
    Me.Left = Screen.Width * .05
    Me.Width = Screen.Width * .9
    Me.Show
End Sub
Sub Form_Paint ()
    Outlines Me
End Sub
Sub Form_Resize ()
    On Error Resume Next
    Monitor.Top = ToolBar.Height + 120
    Monitor.Left = 120
    Monitor.Width = ScaleWidth - 240
    Monitor.Height = ScaleHeight - ToolBar.Height - 240
    List.Width = ScaleWidth - List.Left - 120
End Sub
' This subroutine demonstrates how CatStr (and ArrayStr) Objects
' can be passed to other functions using only the handle.
Sub HintMsg (CHandle As Integer, Title As String)
    HintDialog.Caption = Title
    HintDialog.Hint = CatStrCopy(CHandle)
    HintDialog.Show 1
End Sub
Sub LocateCode (Head As String, Tail As String)
' This subroutine is used by the demonstration program to
' read the form file, locate the desired subroutine (beginning and
' end) and then highlight the text.
' It also serves as an example of the FindStringIC function.
 Dim File    As Integer  ' file handle to load STRDLLAP.FRM
 Dim Buf     As String   ' line buffer
 Dim CHandle As Integer  ' CatStr Object handle
 Dim rc      As Integer  ' return code
 Dim Looping As Integer  ' looping switch while reading file
 Dim locn    As Long     ' location pointer for FindStringIC
 Dim length  As Long     ' calculated length of located text
    ' locate a free file handle
    MousePointer = 11
    List.Clear
    Monitor.Visible = False
    Monitor = ""
    File = FreeFile
    ' create a new CatStr object
    CHandle = CreateNewCatString(32768)
    ' open and read the file
    Open "STRDLLAPP.FRM" For Input As #File
    Looping = True
    While Not EOF(File) And Looping
        Line Input #File, Buf
        ' use the CatStr object to buffer the
        ' lines read from the file
        rc = CatStrAddLine(CHandle, Buf)
        '
        ' stop if no more room in the buffer
        '
        If rc < 0 Then ' can't read any more
            Looping = False
        End If
    Wend
    Close #File
    '
    ' search for the subroutine declaration
    '
    locn = CatStrFind(CHandle, 1, Head)
    '
    ' As long as you haven't fiddled with the code
    ' this should work
    '
    If locn > 0 Then
        length = CatStrFind(CHandle, locn, Tail) - locn + Len(Tail) - 1
        Monitor = CatStrMid$(CHandle, locn, length)
    Else
        MsgBox "This example requires an un-modified version of STRDLLAPP.FRM", 48, "Demo Error"
    End If
    '
    ' ALWAYS REMEMBER TO DESTROY THE OBJECT WHEN FINISHED
    '
    DestroyCatString CHandle
    MousePointer = 0
    Monitor.Visible = True
    Monitor.SetFocus
End Sub
Sub Monitor_KeyPress (KeyAscii As Integer)
    KeyAscii = 0
End Sub
Sub Outlines (FormName As Form)
Dim drkgray     As Long
Dim fullwhite   As Long
Dim i           As Integer
Dim ctop        As Integer
Dim cleft       As Integer
Dim cright      As Integer
Dim cbottom     As Integer
Dim Offset      As Integer
    On Error Resume Next
    Dim cName As Control
    Offset = 0
    FormName.Cls
    drkgray = RGB(128, 128, 128)
    fullwhite = RGB(255, 255, 255)
    For i = 0 To (FormName.Controls.Count - 1)

        Set cName = FormName.Controls(i)
        If TypeOf cName Is Menu Then
            GoTo SkipThisControl

        End If


        If (UCase(cName.Tag) = "OL") Then

            ctop = cName.Top - Screen.TwipsPerPixelY
            cleft = cName.Left - Screen.TwipsPerPixelX
            cright = cName.Left + cName.Width + (Screen.TwipsPerPixelX * Offset)
            cbottom = cName.Top + cName.Height + (Screen.TwipsPerPixelY * Offset)

            FormName.Line (cleft, ctop)-(cright, ctop), drkgray
            FormName.Line (cleft, ctop)-(cleft, cbottom), drkgray
            FormName.Line (cleft, cbottom)-(cright, cbottom), fullwhite
            FormName.Line (cright, ctop)-(cright, cbottom), fullwhite

        End If
SkipThisControl:
    Next i
End Sub
Sub ToolBar_Click ()
    Outlines Me
End Sub